home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
fpkpas92.zip
/
SRCRTL.ZIP
/
RTL
/
DOS
/
GO32V2
/
CRT.PP
next >
Wrap
Text File
|
1997-07-01
|
17KB
|
702 lines
{****************************************************************************
FPKPascal run time library
Copyright (c) 1993,96 by
Florian Klaempfl & Michael Spiegel
****************************************************************************}
{
history:
29th may 1994: version 1.0
unit is completed
14th june 1994: version 1.01
the address from which startaddr was read wasn't right; fixed
18th august 1994: version 1.1
the upper left corner of winmin is now 0,0
19th september 1994: version 1.11
keypressed handles extended keycodes false; fixed
27th february 1995: version 1.12
* crtinoutfunc didn't the line wrap in the right way;
fixed
20th january 1996: version 1.13
- unused variables removed
21th august 1996: version 1.14
* adapted to newer FPKPascal versions
* make the comments english
6th november 1996: version 1.49
* some stuff for DPMI adapted
15th november 1996: version 1.5
* bug in screenrows fixed
}
unit crt;
interface
uses
go32;
const
{ screen modes }
bw40 = 0;
co40 = 1;
bw80 = 2;
co80 = 3;
mono = 7;
font8x8 = 256;
{ screen color, fore- and background }
black = 0;
blue = 1;
green = 2;
cyan = 3;
red = 4;
magenta = 5;
brown = 6;
lightgray = 7;
{ only foreground }
darkgray = 8;
lightblue = 9;
lightgreen = 10;
lightcyan = 11;
lightred = 12;
lightmagenta = 13;
yellow = 14;
white = 15;
{ blink flag }
blink = $80;
var
{ for compatibility }
checkbreak,checkeof,checksnow : boolean;
{ wenn true, wird von screeensetcursor die Graphikkarte }
{ direkt programmiert }
directvideo : boolean;
lastmode : word; { screen mode}
textattr : byte; { current text attribute }
windmin : word; { Rechte obere Ecke des definierten Fensters }
windmax : word; { Linke untere Ecke des definierten Fensters }
function keypressed : boolean;
function readkey : char;
procedure gotoxy(x,y : byte);
procedure window(left,top,right,bottom : byte);
procedure clrscr;
procedure textcolor(color : byte);
procedure textbackground(color : byte);
procedure assigncrt(var f : text);
function wherex : byte;
function wherey : byte;
procedure delline;
procedure delline(line : byte);
procedure clreol;
procedure insline;
procedure cursoron;
procedure cursoroff;
procedure cursorbig;
procedure lowvideo;
procedure highvideo;
procedure nosound;
procedure sound(hz : word);
procedure delay(ms : longint);
procedure textmode(mode : integer);
procedure normvideo;
implementation
var
maxcols,maxrows : longint;
type
pword = ^word;
textbuf = array[0..127] of char;
textrec = record
handle : word;
mode : word;
bufSize : word;
{ private : word; PRIVATE is keyword of FPKPascal }
_private : word;
bufpos : word;
bufend : word;
bufptr : ^textbuf;
openfunc : pointer;
inoutfunc : pointer;
flushfunc : pointer;
closefunc : pointer;
userdata : array[1..16] of byte;
name : string[79];
buffer : textbuf;
end;
{ includes low level routines }
{$i modes.inc}
function screenrows : byte;
begin
dosmemget($40,$84,screenrows,1);
{ don't forget this: }
inc(screenrows);
end;
function screencols : byte;
begin
dosmemget($40,$4a,screencols,1);
end;
function get_addr(row,col : byte) : word;
begin
get_addr:=((row-1)*maxcols+(col-1))*2;
end;
procedure screensetcursor(row,col : longint);
var
cols : byte;
pos : word;
regs : trealregs;
begin
if directvideo then
begin
{ set new position for the BIOS }
dosmemput($40,$51,row,1);
dosmemput($40,$50,col,1);
{ calculates screen position }
dosmemget($40,$4a,cols,1);
{ FPKPascal calculates with 32 bit }
pos:=row*cols+col;
{ direct access to the graphics card registers }
outportb($3d4,$0e);
outportb($3d5,hi(pos));
outportb($3d4,$0f);
outportb($3d5,lo(pos));
end
else
{ asm
movb $0x02,%ah
movb $0,%bh
movb row,%dh
movb col,%dl
pushl %ebp
int $0x10
popl %ebp
end;}
regs.realeax:=$0200;
regs.realebx:=0;
regs.realedx:=row*$100+col;
realintr($10,regs);
end;
procedure screengetcursor(var row,col : longint);
begin
col:=0;
row:=0;
dosmemget($40,$50,col,1);
dosmemget($40,$51,row,1);
end;
{ exported routines }
procedure cursoron;
var regs : trealregs;
begin
{ asm
movb $1,%ah
movb $10,%cl
movb $9,%ch
pushl %ebp
int $0x10
popl %ebp
end;}
regs.realeax:=$0100;
regs.realecx:=$90A;
realintr($10,regs);
end;
procedure cursoroff;
var regs : trealregs;
begin
regs.realeax:=$0100;
regs.realecx:=$ffff;
realintr($10,regs);
{ asm
movb $1,%ah
movb $-1,%cl
movb $-1,%ch
pushl %ebp
int $0x10
popl %ebp
end;}
end;
procedure cursorbig;
var regs : trealregs;
begin
regs.realeax:=$0100;
regs.realecx:=$10A;
realintr($10,regs);
{ begin
asm
movb $1,%ah
movb $10,%cl
movb $1,%ch
pushl %ebp
int $0x10
popl %ebp
end;}
end;
var
is_last : boolean;
last : char;
function readkey : char;
var
char2 : char;
char1 : char;
var regs : trealregs;
begin
if is_last then
begin
is_last:=false;
readkey:=last;
end
else
begin
regs.realeax:=$0000;
realintr($16,regs);
byte(char1):=regs.realeax and $ff;
byte(char2):=(regs.realeax and $ff00) div $100;
{ asm
movb $0,%ah
pushl %ebp
int $0x16
popl %ebp
movw %ax,-2(%ebp)
end;}
if char1=#0 then
begin
is_last:=true;
last:=char2;
end;
readkey:=char1;
end;
end;
function keypressed : boolean;
var regs : trealregs;
begin
if is_last then
begin
keypressed:=true;
exit;
end
else
begin
regs.realeax:=$0100;
realintr($16,regs);
if (regs.realflags and zeroflag) <> 0 then
keypressed:=true
else keypressed:=false;
end;
{ asm
movb $1,%ah
pushl %ebp
int $0x16
popl %ebp
setnz %al
movb %al,__RESULT
end;}
end;
procedure gotoxy(x,y : byte);
begin
if (x<1) then
x:=1;
if (y<1) then
y:=1;
if y+hi(windmin)-2>=hi(windmax) then
y:=hi(windmax)-hi(windmin)+1;
if x+lo(windmin)-2>=lo(windmax) then
x:=lo(windmax)-lo(windmin)+1;
screensetcursor(y+hi(windmin)-1,x+lo(windmin)-1);
end;
function wherex : byte;
var
row,col : longint;
begin
screengetcursor(row,col);
wherex:=col-lo(windmin)+1;
end;
function wherey : byte;
var
row,col : longint;
begin
screengetcursor(row,col);
wherey:=row-hi(windmin)+1;
end;
procedure window(left,top,right,bottom : byte);
begin
if (left<1) or
(right>screencols) or
(bottom>screenrows) or
(left>right) or
(top>bottom) then
exit;
windmin:=(left-1) or ((top-1) shl 8);
windmax:=(right-1) or ((bottom-1) shl 8);
gotoxy(1,1);
end;
procedure clrscr;
var
fil : word;
row : longint;
begin
fil:=32 or (textattr shl 8);
for row:=hi(windmin) to hi(windmax) do
dosmemfillword($b800,get_addr(row+1,lo(windmin)+1),lo(windmax)-lo(windmin)+1,fil);
gotoxy(1,1);
end;
procedure textcolor(color : Byte);
begin
textattr:=(textattr and $70) or color;
end;
procedure lowvideo;
begin
textattr:=textattr and $f7;
end;
procedure highvideo;
begin
textattr:=textattr or $08;
end;
procedure textbackground(color : Byte);
begin
textattr:=(textattr and $8f) or ((color and $7) shl 4);
end;
var
startattrib : byte;
procedure normvideo;
begin
textattr:=startattrib;
end;
procedure delline(line : byte);
var
row,left,right,bot : longint;
fil : word;
begin
row:=line+hi(windmin);
left:=lo(windmin)+1;
right:=lo(windmax)+1;
bot:=hi(windmax)+1;
fil:=32 or (textattr shl 8);
while (row<bot) do
begin
dosmemmove($b800,get_addr(row+1,left),$b800,get_addr(row,left),(right-left+1)*2);
inc(row);
end;
dosmemfillword($b800,get_addr(bot,left),right-left+1,fil);
end;
procedure delline;
begin
delline(wherey);
end;
procedure insline;
var
row,col,left,right,bot : longint;
fil : word;
begin
screengetcursor(row,col);
inc(row);
left:=lo(windmin)+1;
right:=lo(windmax)+1;
bot:=hi(windmax);
fil:=32 or (textattr shl 8);
while (bot>row) do
begin
dosmemmove($b800,get_addr(bot-1,left),$b800,get_addr(bot,left),(right-left+1)*2);
dec(bot);
end;
dosmemfillword($b800,get_addr(row,left),right-left+1,fil);
end;
procedure clreol;
var
row,col : longint;
fil : word;
begin
screengetcursor(row,col);
inc(row);
inc(col);
fil:=32 or (textattr shl 8);
dosmemfillword($b800,get_addr(row,col),lo(windmax)-col+2,fil);
end;
procedure crtinoutfunc(var f : textrec);
var
i,col,row : longint;
c : char;
va,sa : word;
begin
screengetcursor(row,col);
inc(row);
inc(col);
va:=get_addr(row,col);
if f.mode=fmoutput then
begin
for i:=0 to f.bufpos-1 do
begin
c:=f.buffer[i];
case ord(c) of
10 : begin
inc(row);
va:=va+maxcols*2;
end;
13 : begin
col:=lo(windmin)+1;
va:=get_addr(row,col);
end;
8 : if col>lo(windmin)+1 then
begin
dec(col);
va:=va-2;
end;
7 : begin
{ beep }
end;
else
begin
sa:=textattr shl 8 or ord(c);
dosmemput($b800,va,sa,sizeof(sa));
inc(col);
va:=va+2;
end;
end;
if col>lo(windmax)+1 then
begin
col:=lo(windmin)+1;
inc(row);
{ it's easier to calculate the new address }
{ it don't spend much time }
va:=get_addr(row,col);
end;
while row>hi(windmax)+1 do
begin
delline(1);
dec(row);
va:=va-maxcols*2;
end;
end;
f.bufpos:=0;
screensetcursor(row-1,col-1);
end
{!!!!!!}
else halt(100);
end;
procedure assigncrt(var f : text);
begin
textrec(f).inoutfunc:=@crtinoutfunc;
textrec(f).flushfunc:=@crtinoutfunc;
end;
procedure sound(hz : word);
begin
if hz=0 then
begin
nosound;
exit;
end;
asm
movzwl hz,%ecx
movl $1193046,%eax
cdq
divl %ecx
movl %eax,%ecx
movb $0xb6,%al
outb %al,$0x43
movb %cl,%al
outb %al,$0x42
movb %ch,%al
outb %al,$0x42
inb $0x61,%al
orb $0x3,%al
outb %al,$0x61
end ['EAX','ECX','EDX'];
end;
procedure nosound;
begin
asm
inb $0x61,%al
andb $0xfc,%al
outb %al,$0x61
end ['EAX'];
end;
var
calibration : longint;
procedure delay(ms : longint);
var
i,j : longint;
begin
for i:=1 to ms do
for j:=1 to calibration do
begin
end;
end;
function get_ticks : word;
begin
dosmemget($40,$6c,get_ticks,2);
end;
procedure initdelay;
var
first : word;
begin
calibration:=0;
{ wait for new tick }
first:=get_ticks;
while get_ticks=first do
begin
end;
first:=get_ticks;
{ this estimates calibration }
while get_ticks=first do
inc(calibration);
{ calculate this to ms }
calibration:=calibration div 70;
while true do
begin
first:=get_ticks;
while get_ticks=first do
begin
end;
first:=get_ticks;
delay(55);
if first=get_ticks then
exit
else begin
{ decrement calibration two percent }
calibration:=calibration-calibration div 50;
dec(calibration);
end;
end;
end;
procedure textmode(mode : integer);
var
set_font8x8 : boolean;
begin
lastmode:=mode;
set_font8x8:=(mode and font8x8)<>0;
mode:=mode and $ff;
setscreenmode(mode);
windmin:=0;
windmax:=(screencols-1) or ((screenrows-1) shl 8);
maxcols:=screencols;
maxrows:=screenrows;
end;
var
col,row : longint;
begin
is_last:=false;
{ direct access to graphics card registers }
{ direct video generates a GPF in DPMI
of setcursor }
directvideo:=false;
{ set output window }
windmin:=0;
windmax:=(screencols-1) or ((screenrows-1) shl 8);
{ load system variables to temporary variables to save time }
maxcols:=screencols;
maxrows:=screenrows;
{ save the current settings to restore the old state after the exit }
screengetcursor(row,col);
dosmemget($b800,get_addr(row+1,col+1)+1,startattrib,1);
lastmode:=getscreenmode;
textattr:=startattrib;
{ redirect the standard output }
assigncrt(output);
{ calculates delay calibration }
{ initdelay; }
end.